@@ -1,5 +1,8 @@
Revision history for Perl extension Filesys::Notify::Simple
+0.07 Thu Jan 13 11:32:09 PST 2011
+ - Don't die when there's a symlink poiting to something already processed (clkao)
+
0.06 Mon Mar 29 17:21:58 PDT 2010
- Fixed it so ->wait won't die if one of the given directory doesn't exist, on platforms
like Win32.
@@ -4,12 +4,10 @@ author:
- 'Tatsuhiko Miyagawa <miyagawa@bulknews.net>'
build_requires:
ExtUtils::MakeMaker: 6.42
- Test::More: 0
- Test::SharedFork: 0
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.95'
+generated_by: 'Module::Install version 1.00'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -26,4 +24,4 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/miyagawa/Filesys-Notify-Simple.git
-version: 0.06
+version: 0.07
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
}
# Suspend handler for "redefined" warnings
@@ -51,13 +51,18 @@ sub admin {
#line 106
sub is_admin {
- $_[0]->admin->VERSION;
+ ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = $Module::Install::Base::VERSION;
+}
+
my $fake;
sub new {
@@ -75,4 +80,4 @@ BEGIN {
1;
-#line 154
+#line 159
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -4,10 +4,11 @@ package Module::Install::Makefile;
use strict 'vars';
use ExtUtils::MakeMaker ();
use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -101,24 +102,26 @@ sub makemaker_args {
my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
foreach my $key (keys %new_args) {
- if ($makemaker_argtype{$key} eq 'ARRAY') {
- $args->{$key} = [] unless defined $args->{$key};
- unless (ref $args->{$key} eq 'ARRAY') {
- $args->{$key} = [$args->{$key}]
+ if ($makemaker_argtype{$key}) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
}
- push @{$args->{$key}},
- ref $new_args{$key} eq 'ARRAY'
- ? @{$new_args{$key}}
- : $new_args{$key};
- }
- elsif ($makemaker_argtype{$key} eq 'HASH') {
- $args->{$key} = {} unless defined $args->{$key};
- foreach my $skey (keys %{ $new_args{$key} }) {
- $args->{$key}{$skey} = $new_args{$key}{$skey};
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
}
- }
- elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
- $self->makemaker_append($key => $new_args{$key});
}
else {
if (defined $args->{$key}) {
@@ -178,28 +181,22 @@ sub inc {
$self->makemaker_args( INC => shift );
}
-my %test_dir = ();
-
sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- %test_dir = ();
+ my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
- File::Find::find( \&_wanted_t, 'xt' );
- }
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+ File::Find::find(
+ sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
+ $dir
+ );
+ $self->tests( join ' ', sort keys %tests );
}
sub write {
@@ -251,6 +248,9 @@ EOT
$args->{test} = {
TESTS => (join ' ', grep {!$seen{$_}++} @tests),
};
+ } elsif ( $Module::Install::ExtraTests::use_extratests ) {
+ # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
+ # So, just ignore our xt tests here.
} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
$args->{test} = {
TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
@@ -297,13 +297,22 @@ EOT
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
- # Delete bundled dists from prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
+ # Delete bundled dists from prereq_pm, add it to Makefile DIR
+ my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
+ my %processed;
foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $build_prereq->{$file}; #Delete from build prereqs only
+ my ($mod_name, $dist_dir) = @$bundle;
+ delete $prereq->{$mod_name};
+ $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
+ if (not exists $processed{$dist_dir}) {
+ if (-d $dist_dir) {
+ # List as sub-directory to be processed by make
+ push @$subdirs, $dist_dir;
+ }
+ # Else do nothing: the module is already present on the system
+ $processed{$dist_dir} = undef;
+ }
}
}
@@ -356,9 +365,9 @@ sub fix_up_makefile {
. ($self->postamble || '');
local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
@@ -378,7 +387,8 @@ sub fix_up_makefile {
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
@@ -402,4 +412,4 @@ sub postamble {
__END__
-#line 531
+#line 541
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -178,43 +178,6 @@ sub perl_version {
$self->{values}->{perl_version} = $version;
}
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- open_source => undef,
- unrestricted => undef,
- restrictive => undef,
- unknown => undef,
-);
-
-sub license {
- my $self = shift;
- return $self->{values}->{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
sub all_from {
my ( $self, $file ) = @_;
@@ -354,6 +317,9 @@ sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
+
+ # for version integrity check
+ $self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
@@ -364,7 +330,7 @@ sub abstract_from {
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
- );
+ );
}
# Add both distribution and module name
@@ -479,42 +445,89 @@ sub author_from {
}
}
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
+sub license {
+ my $self = shift;
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $license = __extract_license($license) || lc $license;
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
+}
+
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
- (=head \d \s+ (?:licen[cs]e|licensing)\b.*?)
+ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
(=head \d.*|=cut.*|)\z
- /ixms
+ /xms
) || __extract_license(
($matched) = $pod =~ m/
- (=head \d \s+ (?:copyrights?|legal)\b.*?)
+ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
(=head \d.*|=cut.*|)\z
- /ixms
+ /xms
);
}
sub __extract_license {
my $license_text = shift or return;
my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
- 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
- 'Artistic and GPL' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
+ '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
+ '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
+ '(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
@@ -522,6 +535,7 @@ sub __extract_license {
return $license;
}
}
+ return '';
}
sub license_from {
@@ -602,8 +616,15 @@ sub _perl_version {
return $v;
}
-
-
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
######################################################################
@@ -1,36 +1,48 @@
#line 1
package Module::Install::ReadmeFromPod;
+use 5.006;
use strict;
use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.06';
+$VERSION = '0.12';
sub readme_from {
my $self = shift;
- return unless $Module::Install::AUTHOR;
- my $file = shift || return;
+ return unless $self->is_admin;
+
+ my $file = shift || $self->_all_from
+ or die "Can't determine file to make readme_from";
my $clean = shift;
+
+ print "Writing README from $file\n";
+
require Pod::Text;
my $parser = Pod::Text->new();
open README, '> README' or die "$!\n";
$parser->output_fh( *README );
$parser->parse_file( $file );
- return 1 unless $clean;
- $self->postamble(<<"END");
-distclean :: license_clean
-
-license_clean:
-\t\$(RM_F) README
-END
+ if ($clean) {
+ $self->clean_files('README');
+ }
return 1;
}
+sub _all_from {
+ my $self = shift;
+ return unless $self->admin->{extensions};
+ my ($metadata) = grep {
+ ref($_) eq 'Module::Install::Metadata';
+ } @{$self->admin->{extensions}};
+ return unless $metadata;
+ return $metadata->{values}{all_from} || '';
+}
+
'Readme!';
__END__
-#line 89
+#line 112
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';
+ $VERSION = '1.00';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.95';;
+ $VERSION = '1.00';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -22,7 +22,6 @@ use strict 'vars';
use Cwd ();
use File::Find ();
use File::Path ();
-use FindBin;
use vars qw{$VERSION $MAIN};
BEGIN {
@@ -32,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.95';
+ $VERSION = '1.00';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -127,6 +126,11 @@ END_DIE
#-------------------------------------------------------------
unless ( -f $self->{file} ) {
+ foreach my $key (keys %INC) {
+ delete $INC{$key} if $key =~ /Module\/Install/;
+ }
+
+ local $^W;
require "$self->{path}/$self->{dispatch}.pm";
File::Path::mkpath("$self->{prefix}/$self->{author}");
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
@@ -135,12 +139,13 @@ END_DIE
goto &{"$self->{name}::import"};
}
+ local $^W;
*{"${who}::AUTOLOAD"} = $self->autoload;
$self->preload;
# Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
+ delete $INC{'inc/Module/Install.pm'};
+ delete $INC{'Module/Install.pm'};
# Save to the singleton
$MAIN = $self;
@@ -159,7 +164,21 @@ sub autoload {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ($$sym =~ s/([^:]+)$//) {
+ # XXX: it looks like we can't retrieve the missing function
+ # via $$sym (usually $main::AUTOLOAD) in this case.
+ # I'm still wondering if we should slurp Makefile.PL to
+ # get some context or not ...
+ my ($package, $file, $line) = caller;
+ die <<"EOT";
+Unknown function is found at $file line $line.
+Execution of $file aborted due to runtime errors.
+
+If you're a contributor to a project, you may need to install
+some Module::Install extensions from CPAN (or other repository).
+If you're a user of a module, please contact the author.
+EOT
+ }
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
@@ -200,6 +219,7 @@ sub preload {
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
+ local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
@@ -210,12 +230,18 @@ sub preload {
sub new {
my ($class, %args) = @_;
+ delete $INC{'FindBin.pm'};
+ {
+ # to suppress the redefine warning
+ local $SIG{__WARN__} = sub {};
+ require FindBin;
+ }
+
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
-
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
@@ -268,8 +294,10 @@ END_DIE
sub load_extensions {
my ($self, $path, $top) = @_;
+ my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
+ $should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
@@ -277,12 +305,13 @@ sub load_extensions {
next if $self->{pathnames}{$pkg};
local $@;
- my $new = eval { require $file; $pkg->can('new') };
+ my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
- $self->{pathnames}{$pkg} = delete $INC{$file};
+ $self->{pathnames}{$pkg} =
+ $should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
@@ -8,7 +8,7 @@ use Test::Builder;
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
@@ -5,7 +5,7 @@ use 5.006;
use strict;
use warnings;
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -24,7 +24,7 @@ BEGIN {
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
+ # occasionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
@@ -99,25 +99,35 @@ sub child {
$self->croak("You already have a child named ($self->{Child_Name}) running");
}
+ my $parent_in_todo = $self->in_todo;
+
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
+
my $child = bless {}, ref $self;
$child->reset;
# Add to our indentation
$child->_indent( $self->_indent . ' ' );
+
$child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
+ if ($parent_in_todo) {
+ $child->{Fail_FH} = $self->{Todo_FH};
+ }
# This will be reset in finalize. We do this here lest one child failure
# cause all children to fail.
$child->{Child_Error} = $?;
$? = 0;
$child->{Parent} = $self;
+ $child->{Parent_TODO} = $orig_TODO;
$child->{Name} = $name || "Child of " . $self->name;
$self->{Child_Name} = $child->name;
return $child;
}
-#line 201
+#line 211
sub subtest {
my $self = shift;
@@ -129,27 +139,50 @@ sub subtest {
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
- my $child = $self->child($name);
- my %parent = %$self;
- %$self = %$child;
+ my($error, $child, %parent);
+ {
+ # child() calls reset() which sets $Level to 1, so we localize
+ # $Level first to limit the scope of the reset to the subtest.
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $child = $self->child($name);
+ %parent = %$self;
+ %$self = %$child;
+
+ my $run_the_subtests = sub {
+ $subtests->();
+ $self->done_testing unless $self->_plan_handled;
+ 1;
+ };
- my $error;
- if( !eval { $subtests->(); 1 } ) {
- $error = $@;
+ if( !eval { $run_the_subtests->() } ) {
+ $error = $@;
+ }
}
# Restore the parent and the copied child.
%$child = %$self;
%$self = %parent;
+ # Restore the parent's $TODO
+ $self->find_TODO(undef, 1, $child->{Parent_TODO});
+
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
return $child->finalize;
}
+#line 281
+
+sub _plan_handled {
+ my $self = shift;
+ return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
+}
+
-#line 250
+#line 306
sub finalize {
my $self = shift;
@@ -163,6 +196,7 @@ sub finalize {
# XXX This will only be necessary for TAP envelopes (we think)
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $ok = 1;
$self->parent->{Child_Name} = undef;
if ( $self->{Skip_All} ) {
@@ -190,17 +224,17 @@ sub _indent {
return $self->{Indent};
}
-#line 300
+#line 357
sub parent { shift->{Parent} }
-#line 312
+#line 369
sub name { shift->{Name} }
sub DESTROY {
my $self = shift;
- if ( $self->parent ) {
+ if ( $self->parent and $$ == $self->{Original_Pid} ) {
my $name = $self->name;
$self->diag(<<"FAIL");
Child ($name) exited without calling finalize()
@@ -210,7 +244,7 @@ FAIL
}
}
-#line 336
+#line 393
our $Level;
@@ -227,6 +261,7 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
+ $self->{Done_Testing} = 0;
$self->{Original_Pid} = $$;
$self->{Child_Name} = undef;
@@ -256,7 +291,7 @@ sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return;
}
-#line 414
+#line 472
my %plan_cmds = (
no_plan => \&no_plan,
@@ -303,8 +338,7 @@ sub _plan_tests {
return;
}
-
-#line 470
+#line 527
sub expected_tests {
my $self = shift;
@@ -322,7 +356,7 @@ sub expected_tests {
return $self->{Expected_Tests};
}
-#line 494
+#line 551
sub no_plan {
my($self, $arg) = @_;
@@ -335,8 +369,7 @@ sub no_plan {
return 1;
}
-
-#line 528
+#line 584
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -354,7 +387,8 @@ sub _output_plan {
return;
}
-#line 579
+
+#line 636
sub done_testing {
my($self, $num_tests) = @_;
@@ -397,7 +431,7 @@ sub done_testing {
}
-#line 630
+#line 687
sub has_plan {
my $self = shift;
@@ -407,7 +441,7 @@ sub has_plan {
return(undef);
}
-#line 647
+#line 704
sub skip_all {
my( $self, $reason ) = @_;
@@ -421,7 +455,7 @@ sub skip_all {
exit(0);
}
-#line 672
+#line 729
sub exported_to {
my( $self, $pack ) = @_;
@@ -432,7 +466,7 @@ sub exported_to {
return $self->{Exported_To};
}
-#line 702
+#line 759
sub ok {
my( $self, $test, $name ) = @_;
@@ -592,14 +626,12 @@ sub _is_dualvar {
return $numval != 0 and $numval ne $val ? 1 : 0;
}
-#line 876
+#line 933
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_str( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -616,8 +648,6 @@ sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_num( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -675,7 +705,7 @@ sub _isnt_diag {
DIAGNOSTIC
}
-#line 973
+#line 1026
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -709,7 +739,7 @@ sub isnt_num {
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 1022
+#line 1075
sub like {
my( $self, $this, $regex, $name ) = @_;
@@ -725,7 +755,7 @@ sub unlike {
return $self->_regex_ok( $this, $regex, '!~', $name );
}
-#line 1046
+#line 1099
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
@@ -741,8 +771,9 @@ sub cmp_ok {
my($pack, $file, $line) = $self->caller();
+ # This is so that warnings come out at the caller's level
$test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
+#line $line "(eval in cmp_ok) $file"
\$got $type \$expect;
];
$error = $@;
@@ -805,7 +836,7 @@ sub _caller_context {
return $code;
}
-#line 1145
+#line 1199
sub BAIL_OUT {
my( $self, $reason ) = @_;
@@ -815,14 +846,14 @@ sub BAIL_OUT {
exit 255;
}
-#line 1158
+#line 1212
{
no warnings 'once';
*BAILOUT = \&BAIL_OUT;
}
-#line 1172
+#line 1226
sub skip {
my( $self, $why ) = @_;
@@ -853,7 +884,7 @@ sub skip {
return 1;
}
-#line 1213
+#line 1267
sub todo_skip {
my( $self, $why ) = @_;
@@ -881,7 +912,7 @@ sub todo_skip {
return 1;
}
-#line 1293
+#line 1347
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -961,7 +992,7 @@ DIAGNOSTIC
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1389
+#line 1443
sub _try {
my( $self, $code, %opts ) = @_;
@@ -981,7 +1012,7 @@ sub _try {
return wantarray ? ( $return, $error ) : $return;
}
-#line 1418
+#line 1472
sub is_fh {
my $self = shift;
@@ -995,7 +1026,7 @@ sub is_fh {
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1461
+#line 1515
sub level {
my( $self, $level ) = @_;
@@ -1006,7 +1037,7 @@ sub level {
return $Level;
}
-#line 1493
+#line 1547
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -1017,7 +1048,7 @@ sub use_numbers {
return $self->{Use_Nums};
}
-#line 1526
+#line 1580
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -1035,7 +1066,7 @@ foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1579
+#line 1633
sub diag {
my $self = shift;
@@ -1043,7 +1074,7 @@ sub diag {
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1594
+#line 1648
sub note {
my $self = shift;
@@ -1080,7 +1111,7 @@ sub _print_comment {
return 0;
}
-#line 1644
+#line 1698
sub explain {
my $self = shift;
@@ -1099,7 +1130,7 @@ sub explain {
} @_;
}
-#line 1673
+#line 1727
sub _print {
my $self = shift;
@@ -1114,20 +1145,21 @@ sub _print_to_fh {
return if $^C;
my $msg = join '', @msgs;
+ my $indent = $self->_indent;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
+ $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
- return print $fh $self->_indent, $msg;
+ return print $fh $indent, $msg;
}
-#line 1732
+#line 1787
sub output {
my( $self, $fh ) = @_;
@@ -1246,7 +1278,7 @@ sub _copy_io_layers {
return;
}
-#line 1857
+#line 1912
sub reset_outputs {
my $self = shift;
@@ -1258,7 +1290,7 @@ sub reset_outputs {
return;
}
-#line 1883
+#line 1938
sub _message_at_caller {
my $self = shift;
@@ -1279,7 +1311,7 @@ sub croak {
}
-#line 1923
+#line 1978
sub current_test {
my( $self, $num ) = @_;
@@ -1312,7 +1344,7 @@ sub current_test {
return $self->{Curr_Test};
}
-#line 1971
+#line 2026
sub is_passing {
my $self = shift;
@@ -1325,7 +1357,7 @@ sub is_passing {
}
-#line 1993
+#line 2048
sub summary {
my($self) = shift;
@@ -1333,14 +1365,14 @@ sub summary {
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 2048
+#line 2103
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 2077
+#line 2132
sub todo {
my( $self, $pack ) = @_;
@@ -1354,19 +1386,21 @@ sub todo {
return '';
}
-#line 2099
+#line 2159
sub find_TODO {
- my( $self, $pack ) = @_;
+ my( $self, $pack, $set, $new_value ) = @_;
$pack = $pack || $self->caller(1) || $self->exported_to;
return unless $pack;
no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
}
-#line 2117
+#line 2179
sub in_todo {
my $self = shift;
@@ -1375,7 +1409,7 @@ sub in_todo {
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 2167
+#line 2229
sub todo_start {
my $self = shift;
@@ -1390,7 +1424,7 @@ sub todo_start {
return;
}
-#line 2189
+#line 2251
sub todo_end {
my $self = shift;
@@ -1411,7 +1445,7 @@ sub todo_end {
return;
}
-#line 2222
+#line 2284
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1426,9 +1460,9 @@ sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
return wantarray ? @caller : $caller[0];
}
-#line 2239
+#line 2301
-#line 2253
+#line 2315
#'#
sub _sanity_check {
@@ -1441,7 +1475,7 @@ sub _sanity_check {
return;
}
-#line 2274
+#line 2336
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1456,7 +1490,7 @@ WHOA
return;
}
-#line 2298
+#line 2360
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1464,7 +1498,7 @@ sub _my_exit {
return 1;
}
-#line 2310
+#line 2372
sub _ending {
my $self = shift;
@@ -1583,7 +1617,7 @@ END {
$Test->_ending if defined $Test;
}
-#line 2498
+#line 2560
1;
@@ -18,7 +18,7 @@ sub _carp {
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
@@ -247,7 +247,7 @@ sub new_ok {
return $obj;
}
-#line 719
+#line 736
sub subtest($&) {
my ($name, $subtests) = @_;
@@ -256,7 +256,7 @@ sub subtest($&) {
return $tb->subtest(@_);
}
-#line 743
+#line 760
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +270,7 @@ sub fail (;$) {
return $tb->ok( 0, @_ );
}
-#line 806
+#line 823
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -332,7 +332,7 @@ sub _eval {
return( $eval_result, $eval_error );
}
-#line 875
+#line 892
sub require_ok ($) {
my($module) = shift;
@@ -340,7 +340,7 @@ sub require_ok ($) {
my $pack = caller;
- # Try to deterine if we've been given a module name or file.
+ # Try to determine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
@@ -376,7 +376,7 @@ sub _is_module_name {
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
-#line 952
+#line 969
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -476,14 +476,14 @@ sub _type {
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1112
+#line 1129
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +493,13 @@ sub note {
return Test::More->builder->note(@_);
}
-#line 1138
+#line 1155
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1204
+#line 1221
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +527,7 @@ sub skip {
last SKIP;
}
-#line 1288
+#line 1305
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +548,7 @@ sub todo_skip {
last TODO;
}
-#line 1343
+#line 1360
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +557,7 @@ sub BAIL_OUT {
$tb->BAIL_OUT($reason);
}
-#line 1382
+#line 1399
#'#
sub eq_array {
@@ -581,6 +581,8 @@ sub _eq_array {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -591,6 +593,21 @@ sub _eq_array {
return $ok;
}
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
+}
+
sub _deep_check {
my( $e1, $e2 ) = @_;
my $tb = Test::More->builder;
@@ -603,9 +620,6 @@ sub _deep_check {
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -616,7 +630,7 @@ sub _deep_check {
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -683,7 +697,7 @@ WHOA
}
}
-#line 1515
+#line 1546
sub eq_hash {
local @Data_Stack = ();
@@ -706,6 +720,8 @@ sub _eq_hash {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -716,7 +732,7 @@ sub _eq_hash {
return $ok;
}
-#line 1572
+#line 1605
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -741,6 +757,6 @@ sub eq_set {
);
}
-#line 1774
+#line 1807
1;
@@ -7,15 +7,17 @@ use Storable ();
# create new tied array
sub TIEARRAY {
- my ($class, $share) = @_;
- my $self = bless { share => $share }, $class;
+ my ($class, $share, $key) = @_;
+ die "missing key" unless $key;
+ my $self = bless { share => $share, key => $key }, $class;
$self;
}
sub _get {
my $self = shift;
- return $self->{share}->get('array');
+ my $lock = $self->{share}->get_lock();
+ return $self->{share}->get($self->{key});
}
sub FETCH {
my ($self, $index) = @_;
@@ -30,12 +32,12 @@ sub FETCHSIZE {
sub STORE {
my ($self, $index, $val) = @_;
- $self->{share}->lock_cb(sub {
- my $share = $self->{share};
- my $cur = $share->get_nolock('array');
- $cur->[$index] = $val;
- $share->set_nolock(array => $cur);
- });
+ my $lock = $self->{share}->get_lock();
+
+ my $share = $self->{share};
+ my $cur = $share->get($self->{key});
+ $cur->[$index] = $val;
+ $share->set($self->{key} => $cur);
}
1;
@@ -6,19 +6,22 @@ use base 'Tie::Scalar';
# create new tied scalar
sub TIESCALAR {
- my ($class, $initial, $share) = @_;
- bless { share => $share }, $class;
+ my ($class, $share, $key) = @_;
+ die "missing key" unless $key;
+ bless { share => $share, key => $key }, $class;
}
sub FETCH {
my $self = shift;
- $self->{share}->get('scalar');
+ my $lock = $self->{share}->get_lock();
+ $self->{share}->get($self->{key});
}
sub STORE {
my ($self, $val) = @_;
my $share = $self->{share};
- $share->set('scalar' => $val);
+ my $lock = $self->{share}->get_lock();
+ $share->set($self->{key} => $val);
}
1;
@@ -11,14 +11,20 @@ sub new {
my $class = shift;
my %args = @_;
my $filename = File::Temp::tmpnam();
- my $self = bless {callback_on_open => $args{cb}, filename => $filename, lock => 0, pid => $$, ppid => $$}, $class;
+
+ my $init = Storable::dclone($args{init} || +{});
+
+ my $self = bless {
+ callback_on_open => $args{cb},
+ filename => $filename,
+ lock => 0,
+ pid => $$,
+ ppid => $$,
+ }, $class;
$self->open();
# initialize
- Storable::nstore_fd(+{
- array => [],
- scalar => 0,
- }, $self->{fh}) or die "Cannot write initialize data to $filename";
+ Storable::nstore_fd($init, $self->{fh}) or die "Cannot write initialize data to $filename";
return $self;
}
@@ -41,16 +47,6 @@ sub close {
sub get {
my ($self, $key) = @_;
-
- $self->_reopen_if_needed;
- my $ret = $self->lock_cb(sub {
- $self->get_nolock($key);
- }, LOCK_SH);
- return $ret;
-}
-
-sub get_nolock {
- my ($self, $key) = @_;
$self->_reopen_if_needed;
seek $self->{fh}, 0, SEEK_SET or die $!;
Storable::fd_retrieve($self->{fh})->{$key};
@@ -60,15 +56,6 @@ sub set {
my ($self, $key, $val) = @_;
$self->_reopen_if_needed;
- $self->lock_cb(sub {
- $self->set_nolock($key, $val);
- }, LOCK_EX);
-}
-
-sub set_nolock {
- my ($self, $key, $val) = @_;
-
- $self->_reopen_if_needed;
seek $self->{fh}, 0, SEEK_SET or die $!;
my $dat = Storable::fd_retrieve($self->{fh});
@@ -79,23 +66,9 @@ sub set_nolock {
Storable::nstore_fd($dat => $self->{fh}) or die "Cannot store data to $self->{filename}";
}
-sub lock_cb {
- my ($self, $cb) = @_;
-
- $self->_reopen_if_needed;
-
- if ($self->{lock}++ == 0) {
- flock $self->{fh}, LOCK_EX or die $!;
- }
-
- my $ret = $cb->();
-
- $self->{lock}--;
- if ($self->{lock} == 0) {
- flock $self->{fh}, LOCK_UN or die $!;
- }
-
- $ret;
+sub get_lock {
+ my ($self, ) = @_;
+ Test::SharedFork::Store::Locker->new($self);
}
sub _reopen_if_needed {
@@ -118,4 +91,30 @@ sub DESTROY {
}
}
+package # hide from pause
+ Test::SharedFork::Store::Locker;
+
+use Fcntl ':flock';
+
+sub new {
+ my ($class, $store) = @_;
+
+ $store->_reopen_if_needed;
+
+ if ($store->{lock}++ == 0) {
+ flock $store->{fh}, LOCK_EX or die $!;
+ }
+
+ bless { store => $store }, $class;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->{store}->{lock}--;
+ if ($self->{store}->{lock} == 0) {
+ flock $self->{store}->{fh}, LOCK_UN or die $!;
+ }
+}
+
1;
@@ -3,36 +3,119 @@ package Test::SharedFork;
use strict;
use warnings;
use base 'Test::Builder::Module';
-our $VERSION = '0.11';
+our $VERSION = '0.15';
use Test::Builder 0.32; # 0.32 or later is needed
use Test::SharedFork::Scalar;
use Test::SharedFork::Array;
use Test::SharedFork::Store;
+use Config;
use 5.008000;
+{
+ package #
+ Test::SharedFork::Contextual;
+
+ sub call {
+ my $code = shift;
+ my $wantarray = [caller(1)]->[5];
+ if ($wantarray) {
+ my @result = $code->();
+ bless {result => \@result, wantarray => $wantarray}, __PACKAGE__;
+ } elsif (defined $wantarray) {
+ my $result = $code->();
+ bless {result => $result, wantarray => $wantarray}, __PACKAGE__;
+ } else {
+ { ; $code->(); } # void context
+ bless {wantarray => $wantarray}, __PACKAGE__;
+ }
+ }
+
+ sub result {
+ my $self = shift;
+ if ($self->{wantarray}) {
+ return @{ $self->{result} };
+ } elsif (defined $self->{wantarray}) {
+ return $self->{result};
+ } else {
+ return;
+ }
+ }
+}
+
my $STORE;
BEGIN {
- $STORE = Test::SharedFork::Store->new(
- cb => sub {
- my $store = shift;
- tie __PACKAGE__->builder->{Curr_Test}, 'Test::SharedFork::Scalar', 0, $store;
- tie @{ __PACKAGE__->builder->{Test_Results} }, 'Test::SharedFork::Array', $store;
+ my $builder = __PACKAGE__->builder;
+
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ die "# Current version of Test::SharedFork does not supports ithreads.";
+ }
+
+ if (Test::Builder->VERSION > 2.00) {
+ # new Test::Builder
+ $STORE = Test::SharedFork::Store->new();
+
+ our $level = 0;
+ for my $class (qw/Test::Builder2::History Test::Builder2::Counter/) {
+ my $meta = $class->meta;
+ my @methods = $meta->get_method_list;
+ my $orig =
+ $class eq 'Test::Builder2::History'
+ ? $builder->{History}
+ : $builder->{History}->counter;
+ $orig->{test_sharedfork_hacked}++;
+ $STORE->set($class => $orig);
+ for my $method (@methods) {
+ next if $method =~ /^_/;
+ next if $method eq 'meta';
+ next if $method eq 'create';
+ next if $method eq 'singleton';
+ $meta->add_around_method_modifier(
+ $method => sub {
+ my ($code, $orig_self, @args) = @_;
+ return $orig_self->$code(@args) if (! ref $orig_self) || ! $orig_self->{test_sharedfork_hacked};
+
+ my $lock = $STORE->get_lock();
+ local $level = $level + 1;
+ my $self =
+ $level == 1 ? $STORE->get($class) : $orig_self;
+
+ my $ret = Test::SharedFork::Contextual::call(sub { $self->$code(@args) });
+ $STORE->set($class => $self);
+ return $ret->result;
+ },
+ );
+ }
}
- );
+ } else {
+ # older Test::Builder
+ $STORE = Test::SharedFork::Store->new(
+ cb => sub {
+ my $store = shift;
+ tie $builder->{Curr_Test}, 'Test::SharedFork::Scalar',
+ $store, 'Curr_Test';
+ tie @{ $builder->{Test_Results} },
+ 'Test::SharedFork::Array', $store, 'Test_Results';
+ },
+ init => +{
+ Test_Results => $builder->{Test_Results},
+ Curr_Test => $builder->{Curr_Test},
+ },
+ );
+ }
+ # make methods atomic.
no strict 'refs';
no warnings 'redefine';
for my $name (qw/ok skip todo_skip current_test/) {
my $orig = *{"Test::Builder::${name}"}{CODE};
*{"Test::Builder::${name}"} = sub {
- local $Test::Builder::Level += 4;
- my @args = @_;
- $STORE->lock_cb(sub {
- $orig->(@args);
- });
+ local $Test::Builder::Level += 3;
+ my $lock = $STORE->get_lock(); # RAII
+ $orig->(@_);
};
};
+
}
{
@@ -45,4 +128,4 @@ BEGIN {
1;
__END__
-#line 96
+#line 183
@@ -2,7 +2,7 @@ package Filesys::Notify::Simple;
use strict;
use 5.008_001;
-our $VERSION = '0.06';
+our $VERSION = '0.07';
use Carp ();
use Cwd;
@@ -150,6 +150,7 @@ sub _full_scan {
$map{Cwd::realpath($File::Find::dir)}{$fullname} = _stat($fullname);
},
follow_fast => 1,
+ follow_skip => 2,
no_chdir => 1,
}, @path);